home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / tclCmdIL.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-13  |  28.7 KB  |  1,143 lines
  1. #ifdef macintosh
  2. #    pragma segment tclCmdIL
  3. #endif
  4.  
  5. /* 
  6.  * tclCmdIL.c --
  7.  *
  8.  *    This file contains the top-level command routines for most of
  9.  *    the Tcl built-in commands whose names begin with the letters
  10.  *    I through L.  It contains only commands in the generic core
  11.  *    (i.e. those that don't depend much upon UNIX facilities).
  12.  *
  13.  * Copyright 1987-1991 Regents of the University of California
  14.  * Permission to use, copy, modify, and distribute this
  15.  * software and its documentation for any purpose and without
  16.  * fee is hereby granted, provided that the above copyright
  17.  * notice appear in all copies.  The University of California
  18.  * makes no representations about the suitability of this
  19.  * software for any purpose.  It is provided "as is" without
  20.  * express or implied warranty.
  21.  */
  22.  
  23. #ifndef lint
  24. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.84 91/12/06 10:42:36 ouster Exp $ SPRITE (Berkeley)";
  25. #endif
  26.  
  27. #include "tclInt.h"
  28.  
  29. /*
  30.  * Forward declarations for procedures defined in this file:
  31.  */
  32.  
  33. static int        SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  34.                 CONST VOID *second));
  35.  
  36. /*
  37.  *----------------------------------------------------------------------
  38.  *
  39.  * Tcl_IfCmd --
  40.  *
  41.  *    This procedure is invoked to process the "if" Tcl command.
  42.  *    See the user documentation for details on what it does.
  43.  *
  44.  * Results:
  45.  *    A standard Tcl result.
  46.  *
  47.  * Side effects:
  48.  *    See the user documentation.
  49.  *
  50.  *----------------------------------------------------------------------
  51.  */
  52.  
  53.     /* ARGSUSED */
  54. int
  55. Tcl_IfCmd(dummy, interp, argc, argv)
  56.     ClientData dummy;            /* Not used. */
  57.     Tcl_Interp *interp;            /* Current interpreter. */
  58.     int argc;                /* Number of arguments. */
  59.     char **argv;            /* Argument strings. */
  60. {
  61.     char *condition, *ifPart, *elsePart, *cmd, *name;
  62.     char *clause;
  63.     int result, value;
  64.  
  65.     name = argv[0];
  66.     if (argc < 3) {
  67.     ifSyntax:
  68.     Tcl_AppendResult(interp, "wrong # args: should be \"", name,
  69.         " bool ?then? command ?else? ?command?\"", (char *) NULL);
  70.     return TCL_ERROR;
  71.     }
  72.     condition = argv[1];
  73.     argc -= 2;
  74.     argv += 2;
  75.     if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
  76.     argc--;
  77.     argv++;
  78.     }
  79.     if (argc < 1) {
  80.     goto ifSyntax;
  81.     }
  82.     ifPart = *argv;
  83.     argv++;
  84.     argc--;
  85.     if (argc == 0) {
  86.     elsePart = "";
  87.     } else {
  88.     if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
  89.         argc--;
  90.         argv++;
  91.     }
  92.     if (argc != 1) {
  93.         goto ifSyntax;
  94.     }
  95.     elsePart = *argv;
  96.     }
  97.  
  98.     cmd = ifPart;
  99.     clause = "\"then\" clause";
  100.     result = Tcl_ExprBoolean(interp, condition, &value);
  101.     if (result != TCL_OK) {
  102.     if (result == TCL_ERROR) {
  103.         char msg[60];
  104.         sprintf(msg, "\n    (\"if\" test line %d)", interp->errorLine);
  105.         Tcl_AddErrorInfo(interp, msg);
  106.     }
  107.     return result;
  108.     }
  109.     if (value == 0) {
  110.     cmd = elsePart;
  111.     clause = "\"else\" clause";
  112.     }
  113.     if (*cmd == 0) {
  114.     return TCL_OK;
  115.     }
  116.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  117.     if (result == TCL_ERROR) {
  118.     char msg[60];
  119.     sprintf(msg, "\n    (%s line %d)", clause, interp->errorLine);
  120.     Tcl_AddErrorInfo(interp, msg);
  121.     }
  122.     return result;
  123. }
  124.  
  125. /*
  126.  *----------------------------------------------------------------------
  127.  *
  128.  * Tcl_IncrCmd --
  129.  *
  130.  *    This procedure is invoked to process the "incr" Tcl command.
  131.  *    See the user documentation for details on what it does.
  132.  *
  133.  * Results:
  134.  *    A standard Tcl result.
  135.  *
  136.  * Side effects:
  137.  *    See the user documentation.
  138.  *
  139.  *----------------------------------------------------------------------
  140.  */
  141.  
  142.     /* ARGSUSED */
  143. int
  144. Tcl_IncrCmd(dummy, interp, argc, argv)
  145.     ClientData dummy;            /* Not used. */
  146.     Tcl_Interp *interp;            /* Current interpreter. */
  147.     int argc;                /* Number of arguments. */
  148.     char **argv;            /* Argument strings. */
  149. {
  150.     int value;
  151.     char *oldString, *result;
  152.     char newString[30];
  153.  
  154.     if ((argc != 2) && (argc != 3)) {
  155.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  156.         " varName ?increment?\"", (char *) NULL);
  157.     return TCL_ERROR;
  158.     }
  159.  
  160.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  161.     if (oldString == NULL) {
  162.     return TCL_ERROR;
  163.     }
  164.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  165.     Tcl_AddErrorInfo(interp,
  166.         "\n    (reading value of variable to increment)");
  167.     return TCL_ERROR;
  168.     }
  169.     if (argc == 2) {
  170.     value += 1;
  171.     } else {
  172.     int increment;
  173.  
  174.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  175.         Tcl_AddErrorInfo(interp,
  176.             "\n    (reading increment)");
  177.         return TCL_ERROR;
  178.     }
  179.     value += increment;
  180.     }
  181.     sprintf(newString, "%d", value);
  182.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  183.     if (result == NULL) {
  184.     return TCL_ERROR;
  185.     }
  186.     interp->result = result;
  187.     return TCL_OK; 
  188. }
  189.  
  190. /*
  191.  *----------------------------------------------------------------------
  192.  *
  193.  * Tcl_InfoCmd --
  194.  *
  195.  *    This procedure is invoked to process the "info" Tcl command.
  196.  *    See the user documentation for details on what it does.
  197.  *
  198.  * Results:
  199.  *    A standard Tcl result.
  200.  *
  201.  * Side effects:
  202.  *    See the user documentation.
  203.  *
  204.  *----------------------------------------------------------------------
  205.  */
  206.  
  207.     /* ARGSUSED */
  208. int
  209. Tcl_InfoCmd(dummy, interp, argc, argv)
  210.     ClientData dummy;            /* Not used. */
  211.     Tcl_Interp *interp;            /* Current interpreter. */
  212.     int argc;                /* Number of arguments. */
  213.     char **argv;            /* Argument strings. */
  214. {
  215.     register Interp *iPtr = (Interp *) interp;
  216.     int length;
  217.     char c;
  218.     Arg *argPtr;
  219.     Proc *procPtr;
  220.     Var *varPtr;
  221.     Command *cmdPtr;
  222.     Tcl_HashEntry *hPtr;
  223.     Tcl_HashSearch search;
  224.  
  225.     if (argc < 2) {
  226.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  227.         " option ?arg arg ...?\"", (char *) NULL);
  228.     return TCL_ERROR;
  229.     }
  230.     c = argv[1][0];
  231.     length = strlen(argv[1]);
  232.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  233.     if (argc != 3) {
  234.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  235.             argv[0], " args procname\"", (char *) NULL);
  236.         return TCL_ERROR;
  237.     }
  238.     procPtr = TclFindProc(iPtr, argv[2]);
  239.     if (procPtr == NULL) {
  240.         infoNoSuchProc:
  241.         Tcl_AppendResult(interp, "\"", argv[2],
  242.             "\" isn't a procedure", (char *) NULL);
  243.         return TCL_ERROR;
  244.     }
  245.     for (argPtr = procPtr->argPtr; argPtr != NULL;
  246.         argPtr = argPtr->nextPtr) {
  247.         Tcl_AppendElement(interp, argPtr->name, 0);
  248.     }
  249.     return TCL_OK;
  250.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  251.     if (argc != 3) {
  252.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  253.             " body procname\"", (char *) NULL);
  254.         return TCL_ERROR;
  255.     }
  256.     procPtr = TclFindProc(iPtr, argv[2]);
  257.     if (procPtr == NULL) {
  258.         goto infoNoSuchProc;
  259.     }
  260.     iPtr->result = procPtr->command;
  261.     return TCL_OK;
  262.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  263.         && (length >= 2)) {
  264.     if (argc != 2) {
  265.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  266.             " cmdcount\"", (char *) NULL);
  267.         return TCL_ERROR;
  268.     }
  269.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  270.     return TCL_OK;
  271.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  272.         && (length >= 2)){
  273.     if (argc > 3) {
  274.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  275.             " commands [pattern]\"", (char *) NULL);
  276.         return TCL_ERROR;
  277.     }
  278.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  279.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  280.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  281.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  282.         continue;
  283.         }
  284.         Tcl_AppendElement(interp, name, 0);
  285.     }
  286.     return TCL_OK;
  287.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  288.     if (argc != 5) {
  289.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  290.             argv[0], " default procname arg varname\"",
  291.             (char *) NULL);
  292.         return TCL_ERROR;
  293.     }
  294.     procPtr = TclFindProc(iPtr, argv[2]);
  295.     if (procPtr == NULL) {
  296.         goto infoNoSuchProc;
  297.     }
  298.     for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
  299.         if (argPtr == NULL) {
  300.         Tcl_AppendResult(interp, "procedure \"", argv[2],
  301.             "\" doesn't have an argument \"", argv[3],
  302.             "\"", (char *) NULL);
  303.         return TCL_ERROR;
  304.         }
  305.         if (strcmp(argv[3], argPtr->name) == 0) {
  306.         if (argPtr->defValue != NULL) {
  307.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
  308.                 argPtr->defValue, 0) == NULL) {
  309.             defStoreError:
  310.             Tcl_AppendResult(interp,
  311.                 "couldn't store default value in variable \"",
  312.                 argv[4], "\"", (char *) NULL);
  313.             return TCL_ERROR;
  314.             }
  315.             iPtr->result = "1";
  316.         } else {
  317.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
  318.                 == NULL) {
  319.             goto defStoreError;
  320.             }
  321.             iPtr->result = "0";
  322.         }
  323.         return TCL_OK;
  324.         }
  325.     }
  326.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  327.     char *p;
  328.     if (argc != 3) {
  329.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  330.             " exists varName\"", (char *) NULL);
  331.         return TCL_ERROR;
  332.     }
  333.     p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
  334.  
  335.     /*
  336.      * The code below handles the special case where the name is for
  337.      * an array:  Tcl_GetVar will reject this since you can't read
  338.      * an array variable without an index.
  339.      */
  340.  
  341.     if (p == NULL) {
  342.         Tcl_HashEntry *hPtr;
  343.         Var *varPtr;
  344.  
  345.         if (strchr(argv[2], '(') != NULL) {
  346.         noVar:
  347.         iPtr->result = "0";
  348.         return TCL_OK;
  349.         }
  350.         if (iPtr->varFramePtr == NULL) {
  351.         hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  352.         } else {
  353.         hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  354.         }
  355.         if (hPtr == NULL) {
  356.         goto noVar;
  357.         }
  358.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  359.         if (varPtr->flags & VAR_UPVAR) {
  360.         varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
  361.         }
  362.         if (!(varPtr->flags & VAR_ARRAY)) {
  363.         goto noVar;
  364.         }
  365.     }
  366.     iPtr->result = "1";
  367.     return TCL_OK;
  368.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  369.     char *name;
  370.  
  371.     if (argc > 3) {
  372.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  373.             " globals [pattern]\"", (char *) NULL);
  374.         return TCL_ERROR;
  375.     }
  376.     for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
  377.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  378.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  379.         if (varPtr->flags & VAR_UNDEFINED) {
  380.         continue;
  381.         }
  382.         name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
  383.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  384.         continue;
  385.         }
  386.         Tcl_AppendElement(interp, name, 0);
  387.     }
  388.     return TCL_OK;
  389.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  390.         && (length >= 2)) {
  391.     if (argc == 2) {
  392.         if (iPtr->varFramePtr == NULL) {
  393.         iPtr->result = "0";
  394.         } else {
  395.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  396.         }
  397.         return TCL_OK;
  398.     } else if (argc == 3) {
  399.         int level;
  400.         CallFrame *framePtr;
  401.  
  402.         if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
  403.         return TCL_ERROR;
  404.         }
  405.         if (level <= 0) {
  406.         if (iPtr->varFramePtr == NULL) {
  407.             levelError:
  408.             Tcl_AppendResult(interp, "bad level \"", argv[2],
  409.                 "\"", (char *) NULL);
  410.             return TCL_ERROR;
  411.         }
  412.         level += iPtr->varFramePtr->level;
  413.         }
  414.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  415.             framePtr = framePtr->callerVarPtr) {
  416.         if (framePtr->level == level) {
  417.             break;
  418.         }
  419.         }
  420.         if (framePtr == NULL) {
  421.         goto levelError;
  422.         }
  423.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  424.         iPtr->freeProc = (Tcl_FreeProc *) free;
  425.         return TCL_OK;
  426.     }
  427.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  428.         " level [number]\"", (char *) NULL);
  429.     return TCL_ERROR;
  430.     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
  431.         && (length >= 2)) {
  432.     if (argc != 2) {
  433.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  434.             " library\"", (char *) NULL);
  435.         return TCL_ERROR;
  436.     }
  437. #ifdef TCL_LIBRARY
  438.     interp->result = TCL_LIBRARY;
  439.     return TCL_OK;
  440. #else
  441.     interp->result = "there is no Tcl library at this installation";
  442.     return TCL_ERROR;
  443. #endif
  444.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  445.         && (length >= 2)) {
  446.     char *name;
  447.  
  448.     if (argc > 3) {
  449.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  450.             " locals [pattern]\"", (char *) NULL);
  451.         return TCL_ERROR;
  452.     }
  453.     if (iPtr->varFramePtr == NULL) {
  454.         return TCL_OK;
  455.     }
  456.     for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
  457.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  458.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  459.         if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
  460.         continue;
  461.         }
  462.         name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
  463.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  464.         continue;
  465.         }
  466.         Tcl_AppendElement(interp, name, 0);
  467.     }
  468.     return TCL_OK;
  469.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
  470.     if (argc > 3) {
  471.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  472.             " procs [pattern]\"", (char *) NULL);
  473.         return TCL_ERROR;
  474.     }
  475.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  476.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  477.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  478.  
  479.         cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  480.         if (!TclIsProc(cmdPtr)) {
  481.         continue;
  482.         }
  483.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  484.         continue;
  485.         }
  486.         Tcl_AppendElement(interp, name, 0);
  487.     }
  488.     return TCL_OK;
  489.     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
  490.     if (argc != 2) {
  491.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  492.             argv[0], " script\"", (char *) NULL);
  493.         return TCL_ERROR;
  494.     }
  495.     if (iPtr->scriptFile != NULL) {
  496.         interp->result = iPtr->scriptFile;
  497.     }
  498.     return TCL_OK;
  499.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  500.     if (argc != 2) {
  501.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  502.             argv[0], " tclversion\"", (char *) NULL);
  503.         return TCL_ERROR;
  504.     }
  505.  
  506.     /*
  507.      * Note:  TCL_VERSION below is expected to be set with a "-D"
  508.      * switch in the Makefile.
  509.      */
  510.  
  511.     strcpy(iPtr->result, TCL_VERSION);
  512.     return TCL_OK;
  513.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  514.     Tcl_HashTable *tablePtr;
  515.     char *name;
  516.  
  517.     if (argc > 3) {
  518.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  519.             argv[0], " vars [pattern]\"", (char *) NULL);
  520.         return TCL_ERROR;
  521.     }
  522.     if (iPtr->varFramePtr == NULL) {
  523.         tablePtr = &iPtr->globalTable;
  524.     } else {
  525.         tablePtr = &iPtr->varFramePtr->varTable;
  526.     }
  527.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
  528.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  529.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  530.         if (varPtr->flags & VAR_UNDEFINED) {
  531.         continue;
  532.         }
  533.         name = Tcl_GetHashKey(tablePtr, hPtr);
  534.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  535.         continue;
  536.         }
  537.         Tcl_AppendElement(interp, name, 0);
  538.     }
  539.     return TCL_OK;
  540.     } else {
  541.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  542.         "\": should be args, body, commands, cmdcount, default, ",
  543.         "exists, globals, level, library, locals, procs, ",
  544.         "script, tclversion, or vars",
  545.         (char *) NULL);
  546.     return TCL_ERROR;
  547.     }
  548. }
  549.  
  550. /*
  551.  *----------------------------------------------------------------------
  552.  *
  553.  * Tcl_JoinCmd --
  554.  *
  555.  *    This procedure is invoked to process the "join" Tcl command.
  556.  *    See the user documentation for details on what it does.
  557.  *
  558.  * Results:
  559.  *    A standard Tcl result.
  560.  *
  561.  * Side effects:
  562.  *    See the user documentation.
  563.  *
  564.  *----------------------------------------------------------------------
  565.  */
  566.  
  567.     /* ARGSUSED */
  568. int
  569. Tcl_JoinCmd(dummy, interp, argc, argv)
  570.     ClientData dummy;            /* Not used. */
  571.     Tcl_Interp *interp;            /* Current interpreter. */
  572.     int argc;                /* Number of arguments. */
  573.     char **argv;            /* Argument strings. */
  574. {
  575.     char *joinString;
  576.     char **listArgv;
  577.     int listArgc, i;
  578.  
  579.     if (argc == 2) {
  580.     joinString = " ";
  581.     } else if (argc == 3) {
  582.     joinString = argv[2];
  583.     } else {
  584.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  585.         " list ?joinString?\"", (char *) NULL);
  586.     return TCL_ERROR;
  587.     }
  588.  
  589.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  590.     return TCL_ERROR;
  591.     }
  592.     for (i = 0; i < listArgc; i++) {
  593.     if (i == 0) {
  594.         Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
  595.     } else  {
  596.         Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
  597.     }
  598.     }
  599.     ckfree((char *) listArgv);
  600.     return TCL_OK;
  601. }
  602.  
  603. /*
  604.  *----------------------------------------------------------------------
  605.  *
  606.  * Tcl_LindexCmd --
  607.  *
  608.  *    This procedure is invoked to process the "lindex" Tcl command.
  609.  *    See the user documentation for details on what it does.
  610.  *
  611.  * Results:
  612.  *    A standard Tcl result.
  613.  *
  614.  * Side effects:
  615.  *    See the user documentation.
  616.  *
  617.  *----------------------------------------------------------------------
  618.  */
  619.  
  620.     /* ARGSUSED */
  621. int
  622. Tcl_LindexCmd(dummy, interp, argc, argv)
  623.     ClientData dummy;            /* Not used. */
  624.     Tcl_Interp *interp;            /* Current interpreter. */
  625.     int argc;                /* Number of arguments. */
  626.     char **argv;            /* Argument strings. */
  627. {
  628.     char *p, *element;
  629.     int index, size, parenthesized, result;
  630.  
  631.     if (argc != 3) {
  632.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  633.         " list index\"", (char *) NULL);
  634.     return TCL_ERROR;
  635.     }
  636.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  637.     return TCL_ERROR;
  638.     }
  639.     if (index < 0) {
  640.     return TCL_OK;
  641.     }
  642.     for (p = argv[1] ; index >= 0; index--) {
  643.     result = TclFindElement(interp, p, &element, &p, &size,
  644.         &parenthesized);
  645.     if (result != TCL_OK) {
  646.         return result;
  647.     }
  648.     }
  649.     if (size == 0) {
  650.     return TCL_OK;
  651.     }
  652.     if (size >= TCL_RESULT_SIZE) {
  653.     interp->result = (char *) ckalloc((unsigned) size+1);
  654.     interp->freeProc = (Tcl_FreeProc *) free;
  655.     }
  656.     if (parenthesized) {
  657.     memcpy((VOID *) interp->result, (VOID *) element, size);
  658.     interp->result[size] = 0;
  659.     } else {
  660.     TclCopyAndCollapse(size, element, interp->result);
  661.     }
  662.     return TCL_OK;
  663. }
  664.  
  665. /*
  666.  *----------------------------------------------------------------------
  667.  *
  668.  * Tcl_LinsertCmd --
  669.  *
  670.  *    This procedure is invoked to process the "linsert" Tcl command.
  671.  *    See the user documentation for details on what it does.
  672.  *
  673.  * Results:
  674.  *    A standard Tcl result.
  675.  *
  676.  * Side effects:
  677.  *    See the user documentation.
  678.  *
  679.  *----------------------------------------------------------------------
  680.  */
  681.  
  682.     /* ARGSUSED */
  683. int
  684. Tcl_LinsertCmd(dummy, interp, argc, argv)
  685.     ClientData dummy;            /* Not used. */
  686.     Tcl_Interp *interp;            /* Current interpreter. */
  687.     int argc;                /* Number of arguments. */
  688.     char **argv;            /* Argument strings. */
  689. {
  690.     char *p, *element, savedChar;
  691.     int i, index, count, result, size, brace;
  692.  
  693.     if (argc < 4) {
  694.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  695.         " list index element ?element ...?\"", (char *) NULL);
  696.     return TCL_ERROR;
  697.     }
  698.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  699.     return TCL_ERROR;
  700.     }
  701.  
  702.     /*
  703.      * Skip over the first "index" elements of the list, then add
  704.      * all of those elements to the result.
  705.      */
  706.  
  707.     size = 0;
  708.     brace = 0;
  709.     element = argv[1];
  710.     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
  711.     result = TclFindElement(interp, p, &element, &p, &size, &brace);
  712.     if (result != TCL_OK) {
  713.         return result;
  714.     }
  715.     }
  716.     if (*p == 0) {
  717.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  718.     } else {
  719.     char *end;
  720.  
  721.     end = element+size;
  722.     if (brace) {
  723.         end++;
  724.     }
  725.     savedChar = *end;
  726.     *end = 0;
  727.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  728.     *end = savedChar;
  729.     }
  730.  
  731.     /*
  732.      * Add the _new list elements.
  733.      */
  734.  
  735.     for (i = 3; i < argc; i++) {
  736.     Tcl_AppendElement(interp, argv[i], 0);
  737.     }
  738.  
  739.     /*
  740.      * Append the remainder of the original list.
  741.      */
  742.  
  743.     if (*p != 0) {
  744.     Tcl_AppendResult(interp, " ", p, (char *) NULL);
  745.     }
  746.     return TCL_OK;
  747. }
  748.  
  749. /*
  750.  *----------------------------------------------------------------------
  751.  *
  752.  * Tcl_ListCmd --
  753.  *
  754.  *    This procedure is invoked to process the "list" Tcl command.
  755.  *    See the user documentation for details on what it does.
  756.  *
  757.  * Results:
  758.  *    A standard Tcl result.
  759.  *
  760.  * Side effects:
  761.  *    See the user documentation.
  762.  *
  763.  *----------------------------------------------------------------------
  764.  */
  765.  
  766.     /* ARGSUSED */
  767. int
  768. Tcl_ListCmd(dummy, interp, argc, argv)
  769.     ClientData dummy;            /* Not used. */
  770.     Tcl_Interp *interp;            /* Current interpreter. */
  771.     int argc;                /* Number of arguments. */
  772.     char **argv;            /* Argument strings. */
  773. {
  774.     if (argc < 2) {
  775.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  776.         " arg ?arg ...?\"", (char *) NULL);
  777.     return TCL_ERROR;
  778.     }
  779.     interp->result = Tcl_Merge(argc-1, argv+1);
  780.     interp->freeProc = (Tcl_FreeProc *) free;
  781.     return TCL_OK;
  782. }
  783.  
  784. /*
  785.  *----------------------------------------------------------------------
  786.  *
  787.  * Tcl_LlengthCmd --
  788.  *
  789.  *    This procedure is invoked to process the "llength" Tcl command.
  790.  *    See the user documentation for details on what it does.
  791.  *
  792.  * Results:
  793.  *    A standard Tcl result.
  794.  *
  795.  * Side effects:
  796.  *    See the user documentation.
  797.  *
  798.  *----------------------------------------------------------------------
  799.  */
  800.  
  801.     /* ARGSUSED */
  802. int
  803. Tcl_LlengthCmd(dummy, interp, argc, argv)
  804.     ClientData dummy;            /* Not used. */
  805.     Tcl_Interp *interp;            /* Current interpreter. */
  806.     int argc;                /* Number of arguments. */
  807.     char **argv;            /* Argument strings. */
  808. {
  809.     int count, result;
  810.     char *element, *p;
  811.  
  812.     if (argc != 2) {
  813.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  814.         " list\"", (char *) NULL);
  815.     return TCL_ERROR;
  816.     }
  817.     for (count = 0, p = argv[1]; *p != 0 ; count++) {
  818.     result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  819.         (int *) NULL);
  820.     if (result != TCL_OK) {
  821.         return result;
  822.     }
  823.     if (*element == 0) {
  824.         break;
  825.     }
  826.     }
  827.     sprintf(interp->result, "%d", count);
  828.     return TCL_OK;
  829. }
  830.  
  831. /*
  832.  *----------------------------------------------------------------------
  833.  *
  834.  * Tcl_LrangeCmd --
  835.  *
  836.  *    This procedure is invoked to process the "lrange" Tcl command.
  837.  *    See the user documentation for details on what it does.
  838.  *
  839.  * Results:
  840.  *    A standard Tcl result.
  841.  *
  842.  * Side effects:
  843.  *    See the user documentation.
  844.  *
  845.  *----------------------------------------------------------------------
  846.  */
  847.  
  848.     /* ARGSUSED */
  849. int
  850. Tcl_LrangeCmd(notUsed, interp, argc, argv)
  851.     ClientData notUsed;            /* Not used. */
  852.     Tcl_Interp *interp;            /* Current interpreter. */
  853.     int argc;                /* Number of arguments. */
  854.     char **argv;            /* Argument strings. */
  855. {
  856.     int first, last, result;
  857.     char *begin, *end, c, *dummy;
  858.     int count;
  859.  
  860.     if (argc != 4) {
  861.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  862.         " list first last\"", (char *) NULL);
  863.     return TCL_ERROR;
  864.     }
  865.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  866.     return TCL_ERROR;
  867.     }
  868.     if (first < 0) {
  869.     first = 0;
  870.     }
  871.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  872.     last = 1000000;
  873.     } else {
  874.     if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
  875.         Tcl_ResetResult(interp);
  876.         Tcl_AppendResult(interp,
  877.             "expected integer or \"end\" but got \"",
  878.             argv[3], "\"", (char *) NULL);
  879.         return TCL_ERROR;
  880.     }
  881.     }
  882.     if (first > last) {
  883.     return TCL_OK;
  884.     }
  885.  
  886.     /*
  887.      * Extract a range of fields.
  888.      */
  889.  
  890.     for (count = 0, begin = argv[1]; count < first; count++) {
  891.     result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
  892.         (int *) NULL);
  893.     if (result != TCL_OK) {
  894.         return result;
  895.     }
  896.     if (*begin == 0) {
  897.         break;
  898.     }
  899.     }
  900.     for (count = first, end = begin; (count <= last) && (*end != 0);
  901.         count++) {
  902.     result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  903.         (int *) NULL);
  904.     if (result != TCL_OK) {
  905.         return result;
  906.     }
  907.     }
  908.  
  909.     /*
  910.      * Chop off trailing spaces.
  911.      */
  912.  
  913.     while (isspace(end[-1])) {
  914.     end--;
  915.     }
  916.     c = *end;
  917.     *end = 0;
  918.     Tcl_SetResult(interp, begin, TCL_VOLATILE);
  919.     *end = c;
  920.     return TCL_OK;
  921. }
  922.  
  923. /*
  924.  *----------------------------------------------------------------------
  925.  *
  926.  * Tcl_LreplaceCmd --
  927.  *
  928.  *    This procedure is invoked to process the "lreplace" Tcl command.
  929.  *    See the user documentation for details on what it does.
  930.  *
  931.  * Results:
  932.  *    A standard Tcl result.
  933.  *
  934.  * Side effects:
  935.  *    See the user documentation.
  936.  *
  937.  *----------------------------------------------------------------------
  938.  */
  939.  
  940.     /* ARGSUSED */
  941. int
  942. Tcl_LreplaceCmd(notUsed, interp, argc, argv)
  943.     ClientData notUsed;            /* Not used. */
  944.     Tcl_Interp *interp;            /* Current interpreter. */
  945.     int argc;                /* Number of arguments. */
  946.     char **argv;            /* Argument strings. */
  947. {
  948.     char *p1, *p2, *element, savedChar, *dummy;
  949.     int i, first, last, count, result, size, brace;
  950.  
  951.     if (argc < 4) {
  952.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  953.         " list first last ?element element ...?\"", (char *) NULL);
  954.     return TCL_ERROR;
  955.     }
  956.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  957.     return TCL_ERROR;
  958.     }
  959.     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
  960.     return TCL_ERROR;
  961.     }
  962.     if (first < 0) {
  963.     first = 0;
  964.     }
  965.     if (last < 0) {
  966.     last = 0;
  967.     }
  968.     if (first > last) {
  969.     Tcl_AppendResult(interp, "first index must not be greater than second",
  970.         (char *) NULL);
  971.     return TCL_ERROR;
  972.     }
  973.  
  974.     /*
  975.      * Skip over the elements of the list before "first".
  976.      */
  977.  
  978.     size = 0;
  979.     brace = 0;
  980.     element = argv[1];
  981.     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
  982.     result = TclFindElement(interp, p1, &element, &p1, &size, &brace);
  983.     if (result != TCL_OK) {
  984.         return result;
  985.     }
  986.     }
  987.     if (*p1 == 0) {
  988.     Tcl_AppendResult(interp, "list doesn't contain element ",
  989.         argv[2], (char *) NULL);
  990.     return TCL_ERROR;
  991.     }
  992.  
  993.     /*
  994.      * Skip over the elements of the list up through "last".
  995.      */
  996.  
  997.     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
  998.     result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
  999.         (int *) NULL);
  1000.     if (result != TCL_OK) {
  1001.         return result;
  1002.     }
  1003.     }
  1004.  
  1005.     /*
  1006.      * Add the elements up through "first" to the result.
  1007.      */
  1008.  
  1009.     p1 = element+size;
  1010.     if (brace) {
  1011.     p1++;
  1012.     }
  1013.     savedChar = *p1;
  1014.     *p1 = 0;
  1015.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  1016.     *p1 = savedChar;
  1017.  
  1018.     /*
  1019.      * Add the _new list elements.
  1020.      */
  1021.  
  1022.     for (i = 4; i < argc; i++) {
  1023.     Tcl_AppendElement(interp, argv[i], 0);
  1024.     }
  1025.  
  1026.     /*
  1027.      * Append the remainder of the original list.
  1028.      */
  1029.  
  1030.     if (*p2 != 0) {
  1031.     if (*interp->result == 0) {
  1032.         Tcl_SetResult(interp, p2, TCL_VOLATILE);
  1033.     } else {
  1034.         Tcl_AppendResult(interp, " ", p2, (char *) NULL);
  1035.     }
  1036.     }
  1037.     return TCL_OK;
  1038. }
  1039.  
  1040. /*
  1041.  *----------------------------------------------------------------------
  1042.  *
  1043.  * Tcl_LsearchCmd --
  1044.  *
  1045.  *    This procedure is invoked to process the "lsearch" Tcl command.
  1046.  *    See the user documentation for details on what it does.
  1047.  *
  1048.  * Results:
  1049.  *    A standard Tcl result.
  1050.  *
  1051.  * Side effects:
  1052.  *    See the user documentation.
  1053.  *
  1054.  *----------------------------------------------------------------------
  1055.  */
  1056.  
  1057.     /* ARGSUSED */
  1058. int
  1059. Tcl_LsearchCmd(notUsed, interp, argc, argv)
  1060.     ClientData notUsed;            /* Not used. */
  1061.     Tcl_Interp *interp;            /* Current interpreter. */
  1062.     int argc;                /* Number of arguments. */
  1063.     char **argv;            /* Argument strings. */
  1064. {
  1065.     int listArgc;
  1066.     char **listArgv;
  1067.     int i, match;
  1068.  
  1069.     if (argc != 3) {
  1070.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1071.         " list pattern\"", (char *) NULL);
  1072.     return TCL_ERROR;
  1073.     }
  1074.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1075.     return TCL_ERROR;
  1076.     }
  1077.     match = -1;
  1078.     for (i = 0; i < listArgc; i++) {
  1079.     if (Tcl_StringMatch(listArgv[i], argv[2])) {
  1080.         match = i;
  1081.         break;
  1082.     }
  1083.     }
  1084.     sprintf(interp->result, "%d", match);
  1085.     ckfree((char *) listArgv);
  1086.     return TCL_OK;
  1087. }
  1088.  
  1089. /*
  1090.  *----------------------------------------------------------------------
  1091.  *
  1092.  * Tcl_LsortCmd --
  1093.  *
  1094.  *    This procedure is invoked to process the "lsort" Tcl command.
  1095.  *    See the user documentation for details on what it does.
  1096.  *
  1097.  * Results:
  1098.  *    A standard Tcl result.
  1099.  *
  1100.  * Side effects:
  1101.  *    See the user documentation.
  1102.  *
  1103.  *----------------------------------------------------------------------
  1104.  */
  1105.  
  1106.     /* ARGSUSED */
  1107. int
  1108. Tcl_LsortCmd(notUsed, interp, argc, argv)
  1109.     ClientData notUsed;            /* Not used. */
  1110.     Tcl_Interp *interp;            /* Current interpreter. */
  1111.     int argc;                /* Number of arguments. */
  1112.     char **argv;            /* Argument strings. */
  1113. {
  1114.     int listArgc;
  1115.     char **listArgv;
  1116.  
  1117.     if (argc != 2) {
  1118.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1119.         " list\"", (char *) NULL);
  1120.     return TCL_ERROR;
  1121.     }
  1122.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  1123.     return TCL_ERROR;
  1124.     }
  1125.     qsort((VOID *) listArgv, listArgc, sizeof (char *), (void *) SortCompareProc);
  1126.     interp->result = Tcl_Merge(listArgc, listArgv);
  1127.     interp->freeProc = (Tcl_FreeProc *) free;
  1128.     ckfree((char *) listArgv);
  1129.     return TCL_OK;
  1130. }
  1131.  
  1132. /*
  1133.  * The procedure below is called back by qsort to determine
  1134.  * the proper ordering between two elements.
  1135.  */
  1136.  
  1137. static int
  1138. SortCompareProc(first, second)
  1139.     CONST VOID *first, *second;        /* Elements to be compared. */
  1140. {
  1141.     return strcmp(*((char **) first), *((char **) second));
  1142. }
  1143.